home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-exceptions.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  12.3 KB  |  354 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-exceptions.scm,v 1.21 1992/09/10 02:46:10 jmiller Exp $
  39.  
  40. ;;;; The Dylan exception system.
  41.  
  42. ;;; Note: Functions starting with "implementation-specific:" must be
  43. ;;; written for each Scheme implementation.  They go into files like
  44. ;;; "mit-specific.scm".
  45.  
  46. ;;; Classes
  47.  
  48. (define dylan:condition-format-string
  49.   (dylan::generic-fn 'condition-format-string
  50.     (make-param-list `((condition ,<condition>)) #F #F #F)
  51.     (lambda (condition)
  52.       (dylan-call dylan:error
  53.           "(condition-format-string <condition>) -- no specialization"
  54.           condition))))
  55.  
  56. (define dylan:condition-format-arguments
  57.   (dylan::generic-fn 'condition-format-arguments
  58.     (make-param-list `((condition ,<condition>)) #F #F #F)
  59.     (lambda (condition)
  60.       (dylan-call
  61.        dylan:error
  62.        "(condition-format-arguments <condition>) -- no specialization"
  63.        condition))))
  64.  
  65. (dylan::add-slot <simple-error>
  66.   #F 'INSTANCE #F dylan:condition-format-string 'CONDITION-FORMAT-STRING
  67.   #F #F #F 'FORMAT-STRING: #F)
  68. (dylan::add-slot <simple-error>
  69.   #F 'INSTANCE #F dylan:condition-format-arguments
  70.   'CONDITION-FORMAT-ARGUMENTS #F #F #F 'FORMAT-ARGUMENTS: #F)
  71.  
  72. (define dylan:type-error-value
  73.   (dylan::generic-fn 'type-error-value
  74.     (make-param-list `((condition ,<condition>)) #F #F #F)
  75.     (lambda (condition)
  76.       (dylan-call dylan:error
  77.           "(type-error-value <condition>) -- no specialization"
  78.           condition))))
  79.  
  80. (define dylan:type-error-expected-type
  81.   (dylan::generic-fn 'type-error-expected-type
  82.     (make-param-list `((condition ,<condition>)) #F #F #F)
  83.     (lambda (condition)
  84.       (dylan-call dylan:error
  85.           "(type-error-expected-type <condition>) -- no specialization"
  86.           condition))))
  87.  
  88. (dylan::add-slot <type-error>
  89.   #F 'INSTANCE #F dylan:type-error-value 'TYPE-ERROR-VALUE
  90.   #F #F #F 'VALUE: #F)
  91. (dylan::add-slot <type-error>
  92.   #F 'INSTANCE #F dylan:type-error-expected-type
  93.   'TYPE-ERROR-EXPECTED-TYPE #F #F #F 'TYPE: #F)
  94.  
  95. (dylan::add-slot <simple-warning>
  96.   #F 'INSTANCE #F dylan:condition-format-string 'CONDITION-FORMAT-STRING
  97.   #F #F #F 'FORMAT-STRING: #F)
  98. (dylan::add-slot <simple-warning>
  99.   #F 'INSTANCE #F dylan:condition-format-arguments
  100.   'CONDITION-FORMAT-ARGUMENTS #F #F #F 'FORMAT-ARGUMENTS: #F)
  101.  
  102. ;;; Basic Operators (pages 138 and 139)
  103.  
  104. (define (dylan::handler-bind type function test description thunk)
  105.   ;; Assumes function is a method of two args, test is a method of one arg,
  106.   ;; and description is a string or method of one argument.  Can't check???
  107.   (if (and (not (and (class? type) (subclass? type <condition>)))
  108.        (not (and (singleton? type)
  109.              (subclass? (get-type (singleton.object type))
  110.                 <condition>))))
  111.       (dylan-call dylan:error
  112.           "handler-bind -- not a <condition>" type))
  113.   (implementation-specific:push-handler
  114.    type function test description thunk))
  115.  
  116. (define (make-default-condition args type operator)
  117.   ;; Handles one arg (a condition) or many args (format string and format
  118.   ;; args).  Assumes type is a <simple-error> or <simple-warning>.
  119.   (cond ((and (pair? args)
  120.           (subclass? (get-type (car args)) <condition>))
  121.      (if (null? (cdr args))
  122.          (car args)
  123.          (dylan-call dylan:error "extraneous args" operator (cdr args))))
  124.     ((and (pair? args)
  125.           (string? (car args)))
  126.      (dylan-call dylan:make
  127.              type
  128.              'FORMAT-STRING: (car args)
  129.              'FORMAT-ARGUMENTS: (cdr args)))
  130.     (else (dylan-call dylan:error "bad first argument" operator args))))
  131.  
  132. (define (dylan:signal multiple-values next-method . args)
  133.   next-method
  134.   (let* ((condition (make-default-condition args <simple-warning> 'SIGNAL))
  135.      (condition-type (get-type condition)))
  136.     (let frame-loop ((frames
  137.               (implementation-specific:get-dylan-handler-frames)))
  138.       (if (pair? frames)
  139.       (let ((handler-type (caar frames))
  140.         (handler-test (caddar frames)))
  141.         (if (and (or (and (singleton? handler-type)
  142.                   (eq? condition (singleton.object handler-type)))
  143.              (subclass? condition-type handler-type))
  144.              (dylan-call handler-test condition))
  145.         (let ((handler (cadar frames)))
  146.           (dylan-mv-call handler multiple-values
  147.                  condition
  148.                  (lambda (multiple-values next-method)
  149.                    multiple-values next-method
  150.                    (frame-loop (cdr frames)))))
  151.         (frame-loop (cdr frames))))
  152.       (dylan-mv-call dylan:default-handler multiple-values condition)))))
  153.  
  154. ;;; Full set of Operators for Signaling
  155.  
  156. (define dylan:error            ; NOT continuable
  157.   (make-dylan-callable
  158.    (lambda args
  159.      (dylan-call dylan:signal
  160.          (make-default-condition args <simple-error> 'ERROR))
  161.      (dylan-call dylan:error "error -- attempt to return from error"))))
  162.  
  163. (define dylan:cerror            ; OK to continue
  164.   (make-dylan-callable
  165.    (lambda (restart-description . others)
  166.      (call-with-current-continuation
  167.       (lambda (continue)
  168.     (dylan::handler-bind
  169.      <simple-restart>
  170.      (make-dylan-callable        ; Called if restart attempted
  171.       (lambda (condition next-handler)
  172.         condition next-handler
  173.         (continue #F)))
  174.      (make-dylan-callable        ; Test: always ready to handle
  175.       (lambda (condition)
  176.         condition
  177.         #T))
  178.      restart-description
  179.      (lambda ()
  180.        (dylan-apply dylan:error others))))))))
  181.  
  182. (define dylan:break
  183.   (make-dylan-callable
  184.    (lambda args
  185.      (call-with-current-continuation
  186.       (lambda (continue)
  187.     (dylan::handler-bind
  188.      <simple-restart>
  189.      (make-dylan-callable
  190.       (lambda (condition next-handler)
  191.         condition next-handler
  192.         (continue #F)))
  193.      (make-dylan-callable
  194.       (lambda (condition)
  195.         condition
  196.         #T))
  197.      "Continue from breakpoint."
  198.      (lambda ()
  199.        (implementation-specific:enter-debugger
  200.         (make-default-condition args <simple-error> 'BREAK))
  201.        #F)))))))
  202.  
  203. (define dylan:check-type
  204.   (make-dylan-callable
  205.    (lambda (value type)
  206.      (if (not (dylan-call dylan:instance? value type))
  207.      (let ((condition (dylan-call dylan:make
  208.                       <type-error> 'value: value 'type: type)))
  209.        (dylan-call dylan:signal condition))
  210.      value))
  211.    2))
  212.  
  213. (define dylan:abort
  214.   (lambda (multiple-values next-method)
  215.     (dylan-full-call dylan:error multiple-values next-method
  216.              (dylan-call dylan:make <abort>))))
  217.  
  218. ;;; Additional Operators for Handling
  219.  
  220. (define dylan:default-handler
  221.   (dylan::generic-fn 'default-handler
  222.     (make-param-list `((CONDITION ,<condition>)) #F #F #F)
  223.     (lambda (condition) condition #F)))
  224.  
  225. (add-method
  226.  dylan:default-handler
  227.  (dylan::function->method
  228.   (make-param-list `((CONDITION ,<serious-condition>)) #F #F #F)
  229.   (lambda (serious)
  230.     ;; Turn unhandled dylan condition into a Scheme condition unless it is
  231.     ;; a dylan condition reflecting a Scheme condition, in which case, just
  232.     ;; return so that the handler in dylan::catch-all-conditions will
  233.     ;; return so that the remaining Scheme condition handlers may run.
  234.     (let ((error-type (get-type serious)))
  235.       (cond
  236.        ((and (eq? error-type <simple-error>)
  237.          (implementation-specific:is-reflected-error?
  238.           (dylan-call dylan:condition-format-string serious)
  239.           (dylan-call dylan:condition-format-arguments serious)))
  240.     (implementation-specific:let-scheme-handle-it serious))
  241.        ((eq? error-type <simple-error>)
  242.     (implementation-specific:induce-error
  243.      (dylan-call dylan:condition-format-string serious)
  244.      (dylan-call dylan:condition-format-arguments serious)))
  245.        ((eq? error-type <type-error>)
  246.     (let ((value (dylan-call dylan:type-error-value serious))
  247.           (expected-type (dylan-call dylan:type-error-expected-type
  248.                      serious)))
  249.       (implementation-specific:induce-type-error
  250.        value (class.debug-name expected-type))))
  251.        (else
  252.     (implementation-specific:signal-unhandled-dylan-condition
  253.      serious)))))))
  254.  
  255. (add-method
  256.  dylan:default-handler
  257.  (dylan::function->method
  258.   (make-param-list `((CONDITION ,<simple-warning>)) #F #F #F)
  259.   (lambda (warning)
  260.     (implementation-specific:warning
  261.      (dylan-call dylan:condition-format-string warning)
  262.      (dylan-call dylan:condition-format-arguments warning))
  263.     #F)))
  264.  
  265. (add-method
  266.  dylan:default-handler
  267.  (dylan::function->method
  268.   (make-param-list `((CONDITION ,<restart>)) #F #F #F)
  269.   (lambda (restart)
  270.     (dylan-call dylan:error
  271.         "(default-handler <restart>) -- no handler established"
  272.         restart))))
  273.  
  274. ;;; Operators for Interactive Handling
  275.  
  276. (define dylan:restart-query
  277.   (dylan::generic-fn 'restart-query
  278.              (make-param-list `((RESTART ,<restart>)) #F #F #F)
  279.              #F))
  280.  
  281. (add-method
  282.  dylan:restart-query
  283.  (dylan::dylan-callable->method
  284.   (make-param-list `((RESTART ,<restart>)) #F #F #F)
  285.   (lambda (multiple-values next-method restart)
  286.     restart
  287.     (dylan-full-call dylan:values multiple-values next-method))))
  288.  
  289. (define dylan:return-query
  290.   (dylan::generic-fn 'return-query
  291.              (make-param-list `((CONDITION ,<condition>)) #F #F #F)
  292.              #F))
  293.  
  294. (add-method
  295.  dylan:return-query
  296.  (dylan::dylan-callable->method
  297.   (make-param-list `((CONDITION ,<condition>)) #F #F #F)
  298.   (lambda (multiple-values next-method condition)
  299.     condition                ; Ignored
  300.     (display "RETURN-QUERY: please type in a list of values")
  301.     (newline)
  302.     (dylan-full-apply dylan:values multiple-values next-method (read)))))
  303.  
  304. ;;; Operators for Introspection
  305.  
  306. (define dylan:do-handlers
  307.   (make-dylan-callable
  308.    (lambda (funarg)
  309.      (do ((frames
  310.        (implementation-specific:get-dylan-handler-frames)
  311.        (cdr frames)))
  312.      ((null? frames))
  313.        (let ((frame (car frames)))
  314.      (dylan-call funarg
  315.              (car frame) (cadr frame)
  316.              (caddr frame) (cadddr frame))))
  317.      ;; No value???
  318.      #F)
  319.    1))
  320.  
  321. (define dylan:return-allowed?
  322.   (dylan::generic-fn 'return-allowed?
  323.     (make-param-list `((CONDITION ,<condition>)) #F #F #F)
  324.     (lambda (condition) condition #F)))
  325.  
  326. (define dylan:return-description
  327.   (dylan::generic-fn 'return-description
  328.     (make-param-list `((CONDITION ,<condition>)) #F #F #F)
  329.     (lambda (condition)
  330.       (dylan-call dylan:error
  331.           "(return-description <condition>) -- not specialized"
  332.           condition))))
  333.  
  334. ;;; Top-level wrapper for DYLAN code
  335.  
  336. (define catch-errors? #T)
  337.  
  338. (define (dylan::catch-all-conditions dylan-compiled-output)
  339.   (if catch-errors?
  340.       (implementation-specific:catch-all-errors
  341.        dylan::scheme-condition-handler
  342.        dylan-compiled-output)
  343.       (dylan-compiled-output)))
  344.  
  345. ;; A name for the condition handler...
  346. (define (dylan::scheme-condition-handler condition)
  347.   (dylan-call
  348.    dylan:signal
  349.    (dylan-call dylan:make <simple-error>
  350.            'FORMAT-STRING:
  351.            (implementation-specific:get-error-message condition)
  352.            'FORMAT-ARGUMENTS:
  353.            (implementation-specific:get-error-arguments condition))))
  354.